home *** CD-ROM | disk | FTP | other *** search
-
- /* Copyright (C) 1988, 1989 Herve' Touati, Aquarius Project, UC Berkeley */
-
- /* Copyright Herve' Touati, Aquarius Project, UC Berkeley */
-
- #include <stream.h>
- #include <sys/time.h>
- #include <sys/resource.h>
- #include <ctype.h>
- #include "tags.h"
- #include "instr.h"
- #include "hash_table.h"
- #include "string_table.h"
- #include "memory.h"
- #include "scan.h"
- #include "inst_args.h"
- #include "basics.h"
- #include "top_level.h"
- #include "main.h"
-
- enum {
- SHARED_COPY,
- UNSHARED_COPY
- };
-
- /* Copy instructions */
- /* updates the "to" to point to the next available cell */
- /* returns the copy */
- Cell CopyTerm(Cell term, CellPtr& to, int mode)
- {
- CellPtr top_trail = TR;
- register CellPtr first = to;
- register CellPtr second = to;
- *first++ = term;
- while (second < first) {
- Cell value = deref(*second);
- switch (get_tag(value)) {
- case TAGREF:
- switch (mode) {
- case UNSHARED_COPY:
- if (cellp(value) < to || cellp(value) > second) {
- *second = make_ptr(TAGREF, second);
- Bind(value, *second++);
- } else {
- *second++ = value;
- }
- break;
- case SHARED_COPY:
- *second++ = value;
- break;
- }
- break;
- case TAGLIST:
- *second++ = make_ptr(TAGLIST, first);
- Cell* from = addr(value);
- *first++ = *from++;
- *first++ = *from;
- break;
- case TAGSTRUCT:
- *second++ = make_ptr(TAGSTRUCT, first);
- from = addr(value);
- *first++ = *from++;
- int i0 = get_int(*from);
- *first++ = *from++;
- for (int i = 0; i < i0; i++)
- *first++ = *from++;
- break;
- case TAGCONST:
- *second++ = value;
- break;
- }
- }
- CellPtr tr = top_trail;
- CellPtr tr0 = TR;
- for (; tr > tr0; tr--)
- rvalue(*tr) = *tr;
- TR = top_trail;
- Cell result = *to;
- to = first;
- return result;
- }
-
- /* just moves a block by offsetting the pointers by to - from */
- /* since we do not represent structure arities as tagged objects */
- /* we have to make sure in the structure case that */
- /* the arity is correctly copied */
- Cell MoveTerm(Cell value, int block_length, CellPtr& to, int mode)
- {
- register CellPtr p = addr(value);
- register CellPtr q = to;
- int offset = (char*) q - (char*) p;
- for (int i = 0; i < block_length; i++) {
- switch (get_tag(*p)) {
- case TAGREF:
- switch (mode) {
- case UNSHARED_COPY:
- *q++ = *p++ + offset;
- break;
- case SHARED_COPY:
- *q++ = *p++;
- break;
- }
- break;
- case TAGLIST:
- *q++ = *p++ + offset;
- break;
- case TAGSTRUCT:
- *q++ = *p++ + offset;
- break;
- case TAGCONST:
- *q++ = *p++;
- break;
- }
- }
- Cell result = make_ptr(get_tag(value), to);
- to = q;
- return result;
- }
-
- /* only the top level is transformed */
- /* if the list contains lists, these sublists will still be lists */
- /* if from is not a list, or something wrong happens, like the */
- /* first element of the list is not an atom, returns 0 */
-
- Cell SharedFromListToStruct(Cell val, CellPtr& to)
- {
- if (get_tag(val) != TAGLIST || ! is_atom(car(val))) {
- top_level_error("unexpected type in FromListToStruct");
- }
- register CellPtr target = to;
- Cell atom = car(val);
- Cell from = deref(cdr(val));
- int arity = 0;
- target += 2;
- for (; get_tag(from) == TAGLIST; from = deref(cdr(from))) {
- *target++ = car(from);
- arity++;
- }
- if (from != NIL) {
- top_level_error("Second Arg of Univ not NIL terminated");
- }
- if (arity == 0) {
- return atom;
- } else {
- Cell result = make_ptr(TAGSTRUCT, to);
- *to++ = make_atom(SCAN.atom_to_functor(get_id(atom), arity));
- *to = make_int(arity);
- to = target;
- return result;
- }
- }
-
- /* the inverse map of the previous one */
- Cell SharedFromStructToList(Cell val, CellPtr& to)
- {
- if (get_tag(val) != TAGSTRUCT) {
- top_level_error("Unexpected type in SharedFromStructToList");
- }
- register CellPtr origin = addr(val);
- Cell atom = *origin++;
- Cell result = make_ptr(TAGLIST, to);
- *to++ = make_atom(SCAN.functor_to_atom(get_id(atom)));
- *to++ = make_ptr(TAGLIST, to + 1);
- int arity = get_int(*origin++);
- for (int i = 0; i < arity; i++) {
- *to++ = *origin++;
- *to++ = make_ptr(TAGLIST, to + 1);
- }
- *(to - 1) = NIL;
- return result;
- }
-
- Cell Arithm(Cell Arg1, Cell OpCode, Cell Arg2)
- {
- Arg1 = deref(Arg1);
- Arg2 = deref(Arg2);
- if (! is_int(Arg1) || ! is_int(Arg2) || ! is_atom(OpCode))
- return NIL;
- switch(*get_string(OpCode)) {
- #define use(ch,op,shift_before,shift_after)\
- case 'ch':\
- Arg1 = ((Arg1 shift_before) op Arg2) shift_after;\
- return Arg1;
- use(+,+,,) use(-,-,,) use(*,*,>>3,) use(/,/,,<< 3) use(m,%,,)
- #undef use
- default:
- return NIL;
- }
- }
-
- void bind_to_arithmetic_result(Cell Var, Cell result)
- {
- if (result == NIL)
- top_level_error("error in arithmetic expression\n");
- Var = deref(Var);
- switch (get_tag(Var)) {
- case TAGREF:
- Bind(Var, result);
- break;
- case TAGCONST:
- if (Var != result)
- P = FP0;
- break;
- default:
- top_level_error("error in arithmetic expression\n");
- break;
- }
- }
-
- void Is4()
- {
- Cell result = Arithm(X[1], X[2], X[3]);
- bind_to_arithmetic_result(X[0], result);
- }
-
- Cell evaluate(Cell Expr)
- {
- Expr = deref(Expr);
- if (is_int(Expr)) return Expr;
- switch (get_tag(Expr)) {
- case TAGLIST: // yes, C-Prolog does that for some reason
- {
- Cell value = car(Expr);
- Expr = cdr(Expr);
- return (Expr == NIL) ? evaluate(value) : NIL;
- }
- case TAGSTRUCT:
- {
- Cell op = *addr(Expr);
- Cell expr1 = *(addr(Expr) + 2);
- Cell expr2 = *(addr(Expr) + 3);
- expr1 = evaluate(expr1);
- expr2 = evaluate(expr2);
- return Arithm(expr1, op, expr2);
- default:
- return NIL;
- }
- }
- }
-
- void Is2()
- {
- Cell result = evaluate(X[1]);
- bind_to_arithmetic_result(X[0], result);
- }
-
- /* clearly, this routine should only check for the minimum */
- /* does not print more than BREADTH_LIMIT elements of a list or structure */
- /* and does not go deeper than DEPTH_LIMIT levels of recursion */
-
- enum {
- WITH_QUOTES,
- WITHOUT_QUOTES
- };
-
- /* only a simple-minded implementation here */
- inline void print_quote_string(char* s, int quotes)
- {
- if (isalnum(*s))
- quotes = WITHOUT_QUOTES;
- char* string = (quotes == WITH_QUOTES) ? "'" : "";
- fprintf(stderr,"%s%s%s", string, s, string);
- }
-
- void limited_write(CellPtr segment, Cell Var, int depth, int quotes)
- {
- Var = deref(Var);
- if (depth >= DEPTH_LIMIT) {fprintf(stderr,"..."); return;}
- switch (get_tag(Var)) {
- case TAGREF:
- if (segment == H0) {
- if (cellp(Var) < E0)
- fprintf(stderr,"H_%d", cellp(Var) - H0);
- else
- fprintf(stderr,"E_%d", cellp(Var) - E0);
- } else { /* reserved area in that case */
- fprintf(stderr,"R_%d", cellp(Var) - R0);
- }
- return;
- case TAGCONST:
- if (is_int(Var))
- cerr << get_int(Var);
- else
- print_quote_string(get_string(Var), quotes);
- return;
- case TAGLIST:
- fprintf(stderr,"[");
- for (int breadth = 0; breadth < BREADTH_LIMIT; breadth++) {
- limited_write(segment, car(Var), depth + 1, quotes);
- Var = deref(cdr(Var));
- if (get_tag(Var) == TAGLIST) {
- fprintf(stderr,",");
- continue;
- } else if (Var == NIL) {
- break;
- } else {
- fprintf(stderr,"|");
- limited_write(segment, Var, depth + 1, quotes);
- break;
- }
- }
- if (breadth == BREADTH_LIMIT) fprintf(stderr,"...");
- fprintf(stderr,"]");
- return;
- case TAGSTRUCT:
- {
- Cell* ptr = addr(Var);
- fprintf(stderr,"%s(", get_string(*ptr++));
- int i0 = get_int(*ptr++);
- int i = 0;
- for (;;) {
- limited_write(segment, *ptr++, depth + 1, quotes);
- i++;
- if (i >= i0) {cerr << ")"; return;}
- if (i >= BREADTH_LIMIT) {cerr << "...)"; return;}
- cerr << ",";
- }
- }
- }
- }
-
- void Write()
- {limited_write(H0, X[0], 0, WITHOUT_QUOTES);}
-
-
- void Writeq()
- {
- limited_write(H0, X[0], 0, WITH_QUOTES);
- }
-
- void write_term(Cell term)
- {limited_write(H0, term, 0, WITHOUT_QUOTES);}
-
- int same(register Cell arg1, register Cell arg2)
- {
- top_of_the_loop:
- arg1 = deref(arg1);
- arg2 = deref(arg2);
- if (arg1 == arg2) return UNIFY_SUCCESS;
- if (get_tag(arg1) != get_tag(arg2)) return UNIFY_FAIL;
- switch(get_tag(arg1)) {
- case TAGLIST:
- {
- CellPtr S1 = addr(arg1);
- CellPtr S2 = addr(arg2);
- if (same(S1[0], S2[0]) == UNIFY_FAIL) return UNIFY_FAIL;
- arg1 = S1[1];
- arg2 = S2[1];
- goto top_of_the_loop;
- }
- case TAGSTRUCT:
- {
- CellPtr S1 = addr(arg1);
- CellPtr S2 = addr(arg2);
- if (S1[0] != S2[0]) return UNIFY_FAIL;
- int i0 = get_int(S1[1]) + 2;
- for (int i = 2; i < i0; i++)
- if (same(S1[i], S2[i]) == UNIFY_FAIL) return UNIFY_FAIL;
- break;
- }
- default:
- return UNIFY_FAIL;
- }
- }
-
- void Same()
- {
- if (same(X[0], X[1]) == UNIFY_FAIL)
- P = FP0;
- }
- void Nsame()
- {
- if (same(X[0], X[1]) == UNIFY_SUCCESS)
- P = FP0;
- }
-
- #define BUFFER_SIZE 80
- static char buffer[BUFFER_SIZE];
-
- /* initially forgot the case of a list of variables */
- enum {NAME_ATOM, NAME_REF};
-
- void name(Cell val1, Cell val2)
- {
- static char* error_msg = "Illegal call to built-in name(atom, ascii list)";
- val1 = deref(val1);
- val2 = deref(val2);
- Cell list, atom;
- char* p;
- switch (get_tag(val1)) {
- case TAGCONST:
- p = get_string(val1);
- if (is_int(val1)) {
- sprintf(buffer, "%d", get_int(val1));
- p = buffer;
- }
- list = make_ptr(TAGLIST, H);
- for (; *p; p++) {
- *H++ = make_int(*p);
- *H++ = make_ptr(TAGLIST, H + 1);
- }
- *(H - 1) = NIL;
- if (! unify(list, val2))
- P = FP0;
- break;
- case TAGREF:
- if (get_tag(val2) != TAGLIST && val2 != NIL) {
- top_level_error(error_msg);
- }
- p = buffer;
- while (get_tag(val2) == TAGLIST) {
- Cell var = car(val2);
- int ch;
- if (is_int(var) && isascii(ch = get_int(var))) {
- *p++ = ch;
- } else {
- top_level_error(error_msg);
- }
- val2 = deref(cdr(val2));
- }
- if (val2 != NIL) {
- top_level_error(error_msg);
- }
- *p = '\0';
- atom = make_atom(SCAN.intern(buffer));
- if (! unify(atom, val1))
- P = FP0;
- break;
- default:
- top_level_error(error_msg);
- break;
- }
- }
-
- void Name()
- {
- name(X[0], X[1]);
- }
-
- int list_length(Cell list)
- {
- int l = 0;
- while (get_tag(list) == TAGLIST) {
- l++;
- list = deref(cdr(list));
- }
- return l;
- }
-
- void length(Cell val1, Cell val2)
- {
- val1 = deref(val1);
- val2 = deref(val2);
- if (val1 == NIL || get_tag(val1) == TAGLIST) {
- Cell len = list_length(val1);
- if (! unify(make_int(len), val2))
- P = FP0;
- } else if (get_tag(val1) == TAGREF) {
- Bind(val1, NIL);
- if (! unify(make_int(0), val2))
- P = FP0;
- } else {
- P = FP0;
- }
- }
-
- void Length()
- {
- length(X[0], X[1]);
- }
-
- /* time in ms */
- Cell statistics()
- {
- struct rusage info;
- extern void getrusage(...);
- getrusage(RUSAGE_SELF, &info);
- int i = info.ru_utime.tv_sec * 1000 + info.ru_utime.tv_usec / 1000;
- return make_int(i);
- }
-
- void Statistics()
- {
- if (! unify(X[0], statistics()))
- P = FP0;
- }
-
- void univ(Cell val1, Cell val2)
- {
- val1 = deref(val1);
- val2 = deref(val2);
- Cell new_list;
- switch (get_tag(val1)) {
- case TAGSTRUCT:
- Cell* NewH = H;
- val1 = SharedFromStructToList(val1, NewH);
- #ifdef WITH_GC
- if (NewH >= HMAXHARD)
- top_level_error("Heap overflow");
- #else
- if (NewH - H0 > memory_sizes[HEAP_SIZE])
- top_level_error("Heap overflow");
- #endif
- H = NewH;
- if (! unify(val1, val2))
- P = FP0;
- break;
- case TAGLIST:
- new_list = make_ptr(TAGLIST, H);
- *H++ = make_atom(SCAN.functor_to_atom(get_id(LIST_FUNCTOR)));
- *H++ = make_ptr(TAGLIST, H + 1);
- *H++ = car(val1);
- *H++ = make_ptr(TAGLIST, H + 1);
- *H++ = cdr(val1);
- *H++ = NIL;
- if (! unify(new_list, val2))
- P = FP0;
- break;
- case TAGCONST:
- new_list = make_ptr(TAGLIST, H);
- *H++ = val1;
- *H++ = NIL;
- if (! unify(new_list, val2))
- P = FP0;
- break;
- case TAGREF:
- {
- if (val2 == NIL) {
- Bind(val1, NIL);
- return;
- }
- if (get_tag(val2) != TAGLIST) {
- P = FP0;
- return;
- }
- int arity = list_length(val2) - 1;
- Cell atom = car(val2);
- if (get_tag(atom) != TAGCONST || (is_int(atom) && arity != 0)) {
- P = FP0;
- return;
- }
- if (is_int(atom)) {
- Bind(val1, atom);
- return;
- }
- Cell* NewH = H;
- val2 = SharedFromListToStruct(val2, NewH);
- #ifdef WITH_GC
- if (NewH >= HMAXHARD)
- top_level_error("Heap overflow");
- #else
- if (NewH - H0 > memory_sizes[HEAP_SIZE])
- top_level_error("Heap overflow");
- #endif
- H = NewH;
- Bind(val1, val2);
- }
- break;
- }
- }
-
- void Univ()
- {
- univ(X[0], X[1]);
- }
-
- void Tell()
- {}
-
- void Told()
- {}
-
- void Read()
- {}
-
- void functor(Cell val1, Cell val2, Cell val3)
- {
- val1 = deref(val1);
- val2 = deref(val2);
- val3 = deref(val3);
- Cell atom, arity;
- switch (get_tag(val1)) {
- case TAGSTRUCT:
- atom = addr(val1)[0];
- atom = make_atom(SCAN.functor_to_atom(get_id(atom)));
- arity = addr(val1)[1];
- if (! unify(atom, val2)) {P = FP0; return;}
- if (! unify(arity, val3)) {P = FP0; return;}
- break;
- case TAGLIST:
- atom = make_atom(SCAN.functor_to_atom(get_id(LIST_FUNCTOR)));
- if (! unify(atom, val2)) {P = FP0; return;}
- if (! unify(make_int(2), val3)) {P = FP0; return;}
- break;
- case TAGCONST:
- if (! unify(val1, val2)) {P = FP0; return;}
- if (! unify(make_int(0), val3)) {P = FP0; return;}
- break;
- case TAGREF:
- if (! is_int(val3)) {P = FP0; return;}
- if (is_int(val2) && get_int(val3) == 0) {
- Bind(val1, val2);
- return;
- }
- if (is_atom(val2)) {
- int i0 = get_int(val3);
- Bind(val1, make_ptr(TAGSTRUCT, H));
- *H++ = make_atom(SCAN.atom_to_functor(get_id(val2), i0));
- *H++ = val3;
- for (int i = 0; i < i0; i++)
- *H++ = make_ptr(TAGREF, H);
- return;
- }
- P = FP0;
- break;
- default:
- P = FP0;
- }
- }
-
- void Functor()
- {
- functor(X[0], X[1], X[2]);
- }
-
- void arg(Cell val1, Cell val2, Cell val3)
- {
- val1 = deref(val1);
- val2 = deref(val2);
- if (! is_int(val1)) {P = FP0; return;}
- int index = get_int(val1);
- switch (get_tag(val2)) {
- case TAGSTRUCT:
- int arity = get_int(addr(val2)[1]);
- if (! unify(addr(val2)[index + 1], val3))
- P = FP0;
- break;
- case TAGLIST:
- if (! unify(addr(val2)[index - 1], val3))
- P = FP0;
- break;
- default:
- P = FP0;
- break;
- }
- }
-
- void Arg()
- {
- arg(X[0], X[1], X[2]);
- }
- /*
- * We implement here a weak version of assert / retract
- * We allocate a reserved area of memory in which
- * we store entries on an atom or integer.
- * Set copies the term into this memory area, while Access
- * copies it back to the global stack (heap), and unifies it
- * with its argument. No garbage collection is provided.
- * No garbage is generated if only atoms and integers are used.
- */
-
- static HashTable ValueTable;
- static HashTable SizeTable;
-
- void set(Cell key, Cell term)
- {
- Cell value;
- int size;
- term = deref(term);
- switch (get_tag(term)) {
- case TAGREF:
- case TAGLIST:
- case TAGSTRUCT:
- Cell* NewR = R;
- value = CopyTerm(term, NewR, UNSHARED_COPY);
- size = NewR - R;
- R = NewR;
- if (R - R0 > memory_sizes[RESERVED_SIZE]) {
- top_level_error("No more space in assert space");
- }
- break;
- case TAGCONST:
- value = term;
- size = 0;
- break;
- }
- ValueTable.bind(key, value);
- SizeTable.bind(key, size);
- }
-
- void Set()
- {
- set(X[0], X[1]);
- }
-
- void access(Cell key, Cell term)
- {
- Cell value = ValueTable.get(key);
- if (ValueTable.get_status() == HASH_MISS) {
- write_term(key); cerr << ": ";
- top_level_error("accessed before set");
- }
- if (get_tag(value) != TAGCONST) {
- int size = SizeTable.get(key);
- #ifdef WITH_GC
- if (size >= (HMAXSOFT - H)) {
- if (size >= memory_sizes[HEAP_SIZE] - (H2 - H0))
- top_level_error("heap overflow");
- Cell* NewH = H2;
- value = MoveTerm(value, size, NewH, UNSHARED_COPY);
- H2 = NewH;
- } else {
- Cell* NewH = H;
- value = MoveTerm(value, size, NewH, UNSHARED_COPY);
- H = NewH;
- }
- }
- #else
- if (H - H0 > memory_sizes[HEAP_SIZE] - size) {
- top_level_error("heap overflow");
- }
- Cell* NewH = H;
- value = MoveTerm(value, size, NewH, UNSHARED_COPY);
- H = NewH;
- }
- #endif
- if (! unify(term, value))
- P = FP0;
- }
-
- void Access()
- {
- access(X[0], X[1]);
- }
-
- Cell assert_address_and_size(Cell key, int& size)
- {
- Cell value = ValueTable.get(key);
- if (ValueTable.get_status() == HASH_MISS) {
- write_term(key); cerr << ": ";
- top_level_error("accessed before set");
- }
- size = (get_tag(value) != TAGCONST) ? SizeTable.get(key) : 1;
- return value;
- }
-
- /* **************************************** */
- /* The following is for the CALL built-in */
- /* **************************************** */
-
- /* given a string, of the form "proc/arity" */
- /* finds the starting address in the code of the procedure */
- static Instr* get_procedure_addr(int name)
- {
- int addr = instr_args[ARG_PROC]->update(get_id(name));
- if (addr == 0) return 0;
- return (Instr*) addr;
- }
-
- /* given a string, of the form "proc/arity" */
- /* finds the built-in number that matches it */
- /* returns -1 if none. Used by Call */
- static PF get_built_in(int name)
- {
- return instr_args[ARG_BUILTIN]->get_exec(get_id(name));
- }
-
- /* the way this is implemented is as follows: a call(X) is compiled */
- /* into a CALL CALL/1,N or an EXECUTE_PROC CALL/1. THe call/1 routine */
- /* is predefined (it starts at address -4) and contains only one */
- /* instruction, namely ESCAPE CALL/1. Therefore, when the escape is */
- /* executed, the environment for the procedure is already set up. The */
- /* only thing left to do is to load the argument registers and */
- /* execute the routine. Something special has to be done if the arity */
- /* is 9 or more. Right now, just put a trap */
-
- void metacall(Cell term)
- {
- int i, arity;
- Cell name;
- term = deref(term);
- if (get_tag(term) == TAGSTRUCT) {
- name = *addr(term);
- arity = get_int(addr(term)[1]);
- } else if (is_atom(term)) {
- name = make_atom(SCAN.atom_to_functor(term, 0));
- arity = 0;
- } else {
- P = FP0;
- return;
- }
- if (arity > NUMBER_OF_REGISTERS) {
- top_level_error("Metacalls with large arities not supported");
- }
- for (i = 0; i < arity; i++)
- X[i] = addr(term)[i + 2];
- PF function = get_built_in(name);
- if (function != 0) {
- (*function)();
- return;
- }
- Instr* instr = get_procedure_addr(name);
- if (instr != 0) {
- P = instr;
- return;
- }
- cerr << (char*) name << ": ";
- top_level_error("undefined procedure");
- }
-
- void Metacall()
- {
- metacall(X[0]);
- }
-
- void print_args(int arity)
- {
- int i;
- int max = arity - 1;
-
- if (arity == 0) return;
- printf("(");
- for (i = 0; i < max; i++)
- { write_term(*(X + i)); printf(","); }
- write_term(*(X + i));
- printf(")");
- }
-
- void Nl()
- {
- cerr << "\n";
- }
-
- void Var()
- {
- if (get_tag(deref(X[0])) != TAGREF) P = FP0;
- }
-
- void Integer()
- {
- if (! is_int(deref(X[0]))) P = FP0;
- }
-
- void Number()
- {
- if (! is_int(deref(X[0]))) P = FP0;
- }
-
- void Atom()
- {
- if (! is_atom(deref(X[0]))) P = FP0;
- }
-
- #define use(Function,op)\
- void Function()\
- {\
- Cell Arg1 = deref(X[0]);\
- Cell Arg2 = deref(X[1]);\
- if (! is_int(Arg1) || ! is_int(Arg2))\
- P = FP0;\
- if (! (Arg1 op Arg2))\
- P = FP0;\
- }
- use(Gt,>) use(Ge,>=) use(Le,<=) use(Lt,<) use(Neq,!=)
- #undef use
-
- void Assert(){}
- void Retract(){}
-
- void Success()
- {
- top_level_success();
- }
-
- void Failure()
- {
- top_level_failure();
- }
-
- /* this is not in general compatible with CProlog */
- /* it gives only what is needed in practice: */
- /* an arbitrary total order on Prolog values */
- int compare_terms(Cell arg1, Cell arg2)
- {
- arg1 = deref(arg1);
- arg2 = deref(arg2);
- return (arg1 > arg2);
- }
-
- void Gtvar()
- {
- if (! compare_terms(X[0], X[1]))
- P = FP0;
- }
-
- void Ltvar()
- {
- if (compare_terms(X[0], X[1]))
- P = FP0;
- }
-
- void Put()
- {
- fprintf(stderr,"%c", get_int(X[0]));
- }
-
- void Neqarithm()
- {
- Cell val1 = deref(X[0]);
- Cell val2 = deref(X[1]);
- if (! is_int(val1) || ! is_int(val2)) {
- top_level_error("Integer value expected in =\=");
- }
- if (val1 == val2)
- P = FP0;
- }
-
- void RandomInteger()
- {
- extern int random(...);
- extern int srandom(...);
-
- Cell val = deref(X[0]);
- switch (get_tag(val)) {
- case TAGREF:
- Bind(val, make_int(random()));
- break;
- case TAGCONST:
- if (! is_int(val))
- top_level_error("Integer or Variable expected in random\n");
- srandom(get_int(val));
- break;
- default:
- top_level_error("Integer or Variable expected in random\n");
- break;
- }
- }
-